{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusExpr.Beta
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Beta reduction for K Normal Form.
--
--------------------------------------------------------------------------------

module WumpusExpr.Beta
  (
    
    beta

  ) where


import WumpusExpr.FreshMon
import WumpusExpr.KNormal
import WumpusExpr.VarId

import Control.Applicative
import qualified Data.Map as M


--------------------------------------------------------------------------------
-- beta reduction

type Env = M.Map VarId VarId


find :: Env -> VarId -> VarId
find env x = maybe x id $  M.lookup x env

findVal :: Env -> Value -> Value
findVal env (Var v) = Var $ find env v
findVal _   v       = v



beta :: Program -> Mon Program
beta (Program main_proc defs) = 
    Program <$> betaF main_proc <*> mapM betaF defs

betaF :: Fundef -> Mon Fundef
betaF (Fundef hd args body) = Fundef hd args <$> red M.empty body

red :: Env -> Expr -> Mon Expr
red env (Val val)               = Val <$> redV env val

-- red env (Prim v vs)             = return $ Prim v $ map (findVal env) vs

red env (FunCall v vs)          = return $ FunCall v $ map (findVal env) vs

red env (Let vid e1 e2)         = red env e1 >>= \ans -> case ans of
    Val (Var v) -> red (M.insert vid v env) e2
    ea          -> Let vid ea <$> red env e2



red env (Ifte v1 e1 e2)         = 
    Ifte (findVal env v1) <$> red env e1 <*> red env e2

red env (Cmd cmd)               = Cmd <$> redC env cmd

red env (e1 :>> e2)             = (:>>) <$> red env e1 <*> red env e2
red env (Return e)              = Return <$> red env e

redV :: Env -> Value -> Mon Value
redV env (Var vid)        = pure $ Var $ find env vid
redV env (UnaryV op v)    = pure $ UnaryV op (findVal env v)
redV env (BinV op v1 v2)  = pure $ BinV op (findVal env v1) (findVal env v2)
redV env (RelV op v1 v2)  = pure $ RelV op (findVal env v1) (findVal env v2)
redV _   val              = pure val


redC :: Env -> Command -> Mon Command
redC _   (NewPath)                      = pure NewPath
redC _   (ClosePath)                    = pure ClosePath
redC _   (Fill)                         = pure Fill
redC _   (Stroke)                       = pure Stroke
redC env (MoveTo x y)                   = 
    pure $ MoveTo (findVal env x) (findVal env y)

redC env (LineTo x y)                   = 
    pure $ LineTo (findVal env x) (findVal env y)

redC env (CurveTo x1 y1 x2 y2 x3 y3)    = 
    pure $ CurveTo (findVal env x1) (findVal env y1)
                   (findVal env x2) (findVal env y2)
                   (findVal env x3) (findVal env y3)

redC _   (GSave)                        = pure GSave
redC _   (GRestore)                     = pure GRestore
redC env (Scale x y)                    = 
    pure $ Scale (findVal env x) (findVal env y)

redC env (Rotate ang)                   = pure $ Rotate (findVal env ang)

redC env (Translate x y)                =
    pure $ Translate (findVal env x) (findVal env y)

redC env (Transform a b c d e f)        =    
    pure $ Transform (findVal env a) (findVal env b)
                     (findVal env c) (findVal env d)
                     (findVal env e) (findVal env f)

redC env (ShowText v)                   = pure $ ShowText (findVal env v)
